perm filename INIT.PRT[4,LMM] blob sn#037546 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP INITFNS (INITFNS (SPECIAL READFILERESULTS FILELST)
                            WHEREIS READFILE NOBIND COMMENT LODE 
                            FILEFNS SAVVALUE SAVDEF RESTOREVALUE 
                            RESTOREDEF DECIMAL PACK MAKEFILE PRINT1 
                            EVALQUOTE EXPRTYP FEXPRTYP (SETQ FILELST 
                                                             NIL)
                            (INITFN (FUNCTION EVALQUOTE))
                            (NCONC BREAKMACROS
                                   (QUOTE ((PP LIN ((GRINDEF . LIN)))
                                           (STOP NIL (↑))))))
           VALUE)
  (SPECIAL READFILERESULTS FILELST)
  (DEFPROP WHEREIS
           (LAMBDA
             (FN)
             (FOR NEW X IN FILELST WHEN
                  (MEMQ FN (CDR (OR# (GET (FILEFNS X)
                                          (QUOTE VALUE))
                                     (QUOTE (NIL)))))
                  DO
                  (PRIN1 X)
                  (PRINC (QUOTE ","))))
           EXPR)
  (DEFPROP READFILE (LAMBDA (FIL)
                            (PROG (READFILERESULTS)
                                  (INC (EVAL (CONS (QUOTE INPUT)
                                                   FIL)))
                                  LP
                                  (COND ((ERRSET (SETQ READFILERESULTS
                                                       (CONS (READ)
                                                             
                                                    READFILERESULTS))
                                                 ERRORX)
                                         (GO LP))
                                        (T (RETURN (REVERSE 
                                                    READFILERESULTS)))))
                            )
           FEXPR)
  (DEFPROP NOBIND (LAMBDA (X)
                          (OR (NOT X)
                              (EQ (CDR X)
                                  (UNBOUND))))
           EXPR)
  (DEFPROP COMMENT (LAMBDA (COMMENTL)
                           COMMENTL)
           FEXPR)
  (DEFPROP LODE (LAMBDA (FILS)
                        (PROG NIL (COND ((ATOM FILS)
                                         (SETQ FILS (LIST FILS))))
                              (SETQ FILELST (UNION FILELST FILS))
                              (EVAL (CONS (QUOTE DSKIN)
                                          FILS))))
           FEXPR)
  (DEFPROP FILEFNS
           (LAMBDA (FIL)
                   (PROG2 (SETQ
                            FIL
                            (COND
                              ((LITATOM FIL)
                               FIL)
                              ((LITATOM (CAR FIL))
                               (CAR FIL))
                              (T (ERROR (CONS FIL (QUOTE (INVALID
                                                           FILE NAME))))
                                 )))
                          (OR# (GET FIL (QUOTE FILE))
                               (PUTPROP FIL (PACK FIL (QUOTE FNS))
                                        (QUOTE FILE)))))
           EXPR)
  (DEFPROP SAVVALUE (LAMBDA (L)
                            (MAPC (FUNCTION
                                    (LAMBDA (X)
                                            (PUTPROP
                                              X
                                              (GET X (QUOTE VALUE))
                                              (QUOTE OLDVALUE))))
                                  L))
           EXPR)
  (DEFPROP SAVDEF (LAMBDA (L)
                          (MAPC (FUNCTION
                                  (LAMBDA
                                    (X)
                                    (COND ((GET X (QUOTE SUBR))
                                           (PUTPROP
                                             X
                                             (GET X (QUOTE SUBR))
                                             (QUOTE OLDSUBR)))
                                          ((GET X (QUOTE EXPR))
                                           (PUTPROP
                                             X
                                             (GET X (QUOTE EXPR))
                                             (QUOTE OLDEXPR)))
                                          ((GET X (QUOTE FSUBR))
                                           (PUTPROP
                                             X
                                             (GET X (QUOTE FSUBR))
                                             (QUOTE OLDFSUBR)))
                                          ((GET X (QUOTE FEXPR))
                                           (PUTPROP
                                             X
                                             (GET X (QUOTE FEXPR))
                                             (QUOTE OLDFEXPR)))
                                          (T NIL))))
                                L))
           EXPR)
  (DEFPROP RESTOREVALUE (LAMBDA (L)
                                (MAPC (FUNCTION
                                        (LAMBDA
                                          (X)
                                          (PUTPROP X
                                                   (GET X (QUOTE 
                                                           OLDVALUE))
                                                   (QUOTE VALUE))))
                                      L))
           EXPR)
  (DEFPROP RESTOREDEF (LAMBDA
             (L)
             (MAPC (FUNCTION (LAMBDA (X)
                                     (COND
                                       ((GET X (QUOTE OLDSUBR))
                                        (PUTPROP X (GET X (QUOTE 
                                                            OLDSUBR))
                                                 (QUOTE SUBR)))
                                       ((GET X (QUOTE OLDEXPR))
                                        (PUTPROP X (GET X (QUOTE 
                                                            OLDEXPR))
                                                 (QUOTE EXPR)))
                                       ((GET X (QUOTE OLDFSUBR))
                                        (PUTPROP X (GET X (QUOTE 
                                                           OLDFSUBR))
                                                 (QUOTE FSUBR)))
                                       ((GET X (QUOTE OLDFEXPR))
                                        (PUTPROP X (GET X (QUOTE 
                                                           OLDFEXPR))
                                                 (QUOTE FEXPR)))
                                       (T NIL))))
                   L))
           EXPR)
  (DEFPROP DECIMAL (LAMBDA NIL (PROG2 (SETQ *NOPOINT NIL)
                                      (SETQ BASE (SETQ IBASE
                                                       (PLUS 5.0 5.0))))
                           )
           EXPR)
  (DEFPROP PACK (LAMBDA L (READLIST
                          (PROG (FOR-VALUE I)
                                (SETQ I 1.0)
                                LOOP*1
                                (COND ((GREATERP I L)
                                       (GO RETURN)))
                                (SETQ FOR-VALUE
                                      (NCONC FOR-VALUE
                                             (EXPLODEC (ARG I))))
                                NEXT*1 NEXT*I (SETQ I (PLUS I 1.0))
                                (GO LOOP*1)
                                RETURN
                                (RETURN FOR-VALUE))))
           EXPR)
  (DEFPROP MAKEFILE (LAMBDA (FIL)
                            (EVAL (LIST (QUOTE DSKOUT)
                                        FIL
                                        (FILEFNS FIL))))
           EXPR)
  (DEFPROP PRINT1 (LAMBDA (MESS)
                          (PROG1 (PRINT MESS)
                                 (TERPRI)))
           EXPR)
  (DEFPROP
    EVALQUOTE
    (LAMBDA
      NIL
      (PROG
        (LISPXLINE TEM)
        (DECIMAL)
        (PROMPT 95.0)
        LOOP
        (SETQ LISPXLINE (LINEREAD))
        LOOP2
        (COND
          ((SETQ TEM (ASSOC (CAR LISPXLINE)
                            BREAKMACROS))
           (SETQ LISPXLINE (SUBST (CDR LISPXLINE)
                                  (CADR TEM)
                                  (CADDR TEM)))
           (GO LOOP2))
          ((NULL (CDR LISPXLINE))
           (COND
             ((AND (LITATOM (CAR LISPXLINE))
                   (NOBIND (GET (CAR LISPXLINE)
                                (QUOTE VALUE))))
              (COND
                ((OR (FEXPRTYP (CAR LISPXLINE))
                     (GET (CAR LISPXLINE)
                          (QUOTE SUBR))
                     (AND (GET (CAR LISPXLINE)
                               (QUOTE EXPR))
                          (ZEROP (LENGTH (CADR (GET (CAR LISPXLINE)
                                                    (QUOTE EXPR)))))))
                 (PRINT1 (EVAL LISPXLINE)))
                (T (PRINT1 (QUOTE ???)))))
             (T (PRINT1 (EVAL (CAR LISPXLINE))))))
          ((NOT (CDDR LISPXLINE))
           (COND ((EXPRTYP (CAR LISPXLINE))
                  (PRINT1 (APPLY (CAR LISPXLINE)
                                 (CADR LISPXLINE))))
                 ((FEXPRTYP (CAR LISPXLINE))
                  (PRINT1 (EVAL (CONS (CAR LISPXLINE)
                                      (CADR LISPXLINE)))))
                 (T (PRINT1 (APPLY (CAR LISPXLINE)
                                   (CDR LISPXLINE))))))
          (T (MAPC (QUOTE EVAL)
                   LISPXLINE)))
        (GO LOOP)))
    EXPR)
  (DEFPROP EXPRTYP (LAMBDA (X)
                           (COND ((LITATOM X)
                                  (OR (GET X (QUOTE SUBR))
                                      (GET X (QUOTE EXPR))))
                                 ((CONSP X)
                                  (EQ (CAR X)
                                      (QUOTE LAMBDA)))
                                 (T NIL)))
           EXPR)
  (DEFPROP FEXPRTYP (LAMBDA (X)
                            (AND (LITATOM X)
                                 (OR (GET X (QUOTE SUBR))
                                     (GET X (QUOTE FSUBR)))))
           EXPR)
  (SETQ FILELST NIL)
  (INITFN (FUNCTION EVALQUOTE))
  (NCONC BREAKMACROS (QUOTE ((PP LIN ((GRINDEF . LIN)))
                             (STOP NIL (↑)))))
STOP